COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*- LISP -*-
C00004 00003
C00009 00004
C00010 ENDMK
C⊗;
;;; -*- LISP -*-

(HERALD TRNPUT "")

(DECLARE (*LEXPR SCH-ERROR))

;;;; Internal Transput Routines

(DECLARE (SPECIAL *ibase* *obase* *outstream* *outstreams*
		  *script-stream* *implode-sfa*))

(DECLARE (SPECIAL *NOPRINT* *implodable*))


;;; Gjc-reader and related functions:

;(include "scm:gjc-re")

(defun schreadch args (ascii (apply #'tty-tyi (listify args))))

;;; functions strictly for TTY output.

(DEFUN SCHBEEP-AT-USER ()
  (TYO #\BELL TYO)
  *NOPRINT*)


(DEFUN SCHTERPRI () (SCH-TERPRI *OUTSTREAM*))
(DEFUN SCHTYO (X) (SCH-TYO X *OUTSTREAM*))

;;; stream output operations.

(DEFUN SCH-TYO (X STREAM)
  (TYO X STREAM)
  *NOPRINT*)

(DEFUN SCH-TERPRI (STREAM)
  (TERPRI STREAM)
  *NOPRINT*)

(DEFUN SCH-PRIN1 (FORM STREAM)
  (PRIN1 FORM STREAM)
  *NOPRINT*)

;;; Include the Waters printer and scheme modifications:
;(INCLUDE "SPRINT.lsp")


;;;; I/O Support

;;; (SCH-OUTSTREAM-HANDLER self op data) - An SFA which takes all output
;;;	fed to it and outputs it to any streams on *OUTSTREAMS*.

(DEFUN SCH-OUTSTREAM-HANDLER (SELF OP DATA)
  (CASEQ OP
    ((WHICH-OPERATIONS) '(TYO CHARPOS LINEL))
    ((TYO)
     (IF (NOT (MINUSP DATA)) (TYO DATA *OUTSTREAMS*)))
    ((CHARPOS LINEL)
     (FUNCALL OP (CAR *OUTSTREAMS*)))
    (T							; Bad error
     (SCH-ERROR "SCHEME Bug: Please report this. Illegal output SFA operation."
		`(SFA-CALL ,SELF ,OP ,DATA)))))

(DEFUN SCH-FRESH-LINE (STREAM)
  (COND ((AND (SFAP STREAM)
	      (MEMQ 'FRESH-LINE (SFA-CALL STREAM 'WHICH-OPERATIONS NIL )))
	 (SFA-CALL STREAM 'FRESH-LINE NIL))
	((NOT (ZEROP (CHARPOS STREAM)))
	 (TERPRI STREAM)))
  *NOPRINT*)

(DEFUN SCHFRESH-LINE ()
  (SCH-FRESH-LINE *OUTSTREAM*))

(DEFUN CLEAR-SCREEN ()
  (CURSORPOS 'C)
  *NOPRINT*)


;;; Hardcopy control functions
;;;

(DEFUN SCH-PHOTO (FILENAME)
  (COND (*SCRIPT-STREAM* (SCHPRINT ";Shutter already open"))
	(T (SETQ ↑R T)
	   (SETQ *SCRIPT-STREAM*
		 (OPEN (COND ((STATUS FEATURE TOPS-20)
			      (MERGEF FILENAME
				      `((PS ,(STATUS UDIR)) SCHEME OUTPUT /-1)))
			     ((STATUS FEATURE ITS)
			      (MERGEF FILENAME
				      `((DSK ,(STATUS UDIR)) SCHDRB >)))
			     (T FILENAME))
		       'OUT))
	   (PUSH *SCRIPT-STREAM* *OUTSTREAMS*)
	   (PUSH *SCRIPT-STREAM* ECHOFILES)
	   (PUSH *SCRIPT-STREAM* MSGFILES)
	   *NOPRINT*)))

(DEFUN SCH-TOFU ()
  (COND ((NOT *SCRIPT-STREAM*) (SCHPRINT ";Shutter already closed"))
	(T (SETQ ↑R NIL)
	   (SETQ MSGFILES  (DELETE *SCRIPT-STREAM* MSGFILES))
	   (SETQ ECHOFILES (DELETE *SCRIPT-STREAM* ECHOFILES))
	   (SETQ *OUTSTREAMS*
		 (DELETE *SCRIPT-STREAM* *OUTSTREAMS*))
	   (CLOSE *SCRIPT-STREAM*)
	   (SETQ *SCRIPT-STREAM* NIL)
	   *NOPRINT*)))


;;; (SCH-IMPLODE char-list) - A SCHEME version of Maclisp's READLIST.
;;; (SCH-IMPLODE-HANDLER self op data) - An SFA helper for SCH-IMPLODE.

(DEFUN SCH-IMPLODE (CHAR-LIST)
  (LET ((*IMPLODABLE* CHAR-LIST))
    (READ *IMPLODE-SFA*)))

(DEFUN SCH-IMPLODE-HANDLER (SELF OP DATA)
  (CASEQ OP
    (WHICH-OPERATIONS '(UNTYI TYI))
    (UNTYI (PUSH DATA *IMPLODABLE*))
    (TYI (COND ((NULL *IMPLODABLE*)			; Out of chars?
		(SETQ *IMPLODABLE* T)			;  Set flag to avoid infinite loop
		#\SPACE)				;  Output a trailing break char
	       ((ATOM *IMPLODABLE*)			; Check for infinite loop
		(sch-error "IMPLODE ran out of characters"))
	       (T
		(LET ((CHAR (POP *IMPLODABLE*)))
		  (COND ((SYMBOLP CHAR) (GETCHARN CHAR 1.))
			(T CHAR))))))
    (T (SCH-ERROR "UnSupported Operation" (LIST 'SFA-CALL SELF OP DATA)))))

(DEFUN SCHPEEKCH ()
  (ASCII (TYIPEEK)))

(DEFUN SCHCVTN (X)
  (GETCHARN X 1.))


;;; Initialize special printer variables

(SETQ *IBASE* 10.
      *OBASE* 10.
      *OUTSTREAM* (SFA-CREATE 'SCH-OUTSTREAM-HANDLER 0. "Output Handler")
      *OUTSTREAMS* (NCONS TYO)
      *SCRIPT-STREAM* NIL
      *IMPLODE-SFA* (SFA-CREATE 'SCH-IMPLODE-HANDLER 0. "Implode Handler"))